-- bunkplan.ml - Generate (crappy) HTML bunkplans from CSV
-- Copyright (C) 2012  Jack Kelly
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

import Data.Char
import Data.Function
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import System.Exit
import System.FilePath
import System.Environment
import Text.CSV
import Text.Html hiding (name)
import Text.ParserCombinators.Parsec.Error
import Text.Printf

data Crew = Captain
          | Chef
          | Mate Int
          | Passenger
          | WatchAssistant
          | WatchLeader deriving Show

data Watch = Red | White | Blue deriving Show

watchLabel :: Watch -> Html
watchLabel = toHtml . (map toUpper) . show

watchLabelColor :: Watch -> Html
watchLabelColor w = colorize $ watchLabel w where
    colorize = case w of
                 Red -> (! [color red]) . font
                 White -> id
                 Blue -> (! [color blue]) . font

data Sex = Male | Female deriving Show

data BunkDefinition = BunkDefinition {
      number :: String, -- Yes, string, to handle bunk 9A and so on.
      cabin :: String,
      bunkName :: String
    } deriving Show

data BunkAssignment = BunkAssignment {
      musterNumber :: Int,
      crewType :: Crew,
      watch :: Watch,
      name :: String,
      sex :: Sex,
      bunkNumber :: String,
      liferaft :: String,
      emergencyStation :: String
    } deriving Show

data BunkPlan = BunkPlan {
      assignment :: [BunkAssignment],
      bunks :: [BunkDefinition]
    } deriving Show

-- Split up the csv into assignments, bunks and excluded cabins (no parsing).
split :: CSV -> ([Record], [Record], [Record])
split rows = (assignments, bunks, excludes) where
    assignments = chunk rows "#BUNKPLAN"
    bunks = chunk rows "#BUNKS"
    excludes = chunk rows "#EXCLUDE"
    chunk list mark = takeWhile notHash $ tail $ dropWhile notMark list where
                                            notHash = ((/= '#') . head . head)
                                            notMark = (/= mark) . head

-- Parsing Functions.
parseCrew :: String -> Crew
parseCrew "CO" = Captain
parseCrew "CH" = Chef
parseCrew "M1" = Mate 1
parseCrew "M2" = Mate 2
parseCrew "M3" = Mate 3
parseCrew "WA" = WatchAssistant
parseCrew "WL" = WatchLeader
parseCrew "" = Passenger
parseCrew _ = error "Invalid passenger type."

parseWatch :: String -> Watch
parseWatch "R" = Red
parseWatch "W" = White
parseWatch "B" = Blue
parseWatch _ = error "Invalid Watch."

parseSex :: String -> Sex
parseSex "M" = Male
parseSex "F" = Female
parseSex "" = error "Invalid Sex."

parseAssignments :: [Record] -> [BunkAssignment]
parseAssignments = iter [] where
    iter acc [] = reverse acc
    iter acc ([num,
               crew,
               watch,
               name,
               sex,
               bunk,
               liferaft,
               emergencyStation]:rs) = iter (assign:acc) rs where
                           assign = BunkAssignment {
                                      musterNumber = read num,
                                      crewType = parseCrew crew,
                                      watch = parseWatch watch,
                                      name = name,
                                      sex = parseSex sex,
                                      bunkNumber = bunk,
                                      liferaft = liferaft,
                                      emergencyStation = emergencyStation
                                    }
    iter acc _ = error "Format error in watchbill."

parseDefinitions :: [Record] -> [BunkDefinition]
parseDefinitions = iter [] where
    iter acc [] = reverse acc
    iter acc ([num, cabin, name]:rs) = iter (def:acc) rs where
                           def = BunkDefinition {
                                   number = num,
                                   cabin = cabin,
                                   bunkName = name
                                 }
    iter acc _ = error "Format error in bunk definition."

-- Trim a CSV file: remove empty columns on the left, empty rows at
-- top or bottom and empty cells at the end of the row.
trimCSV :: CSV -> CSV
trimCSV = trimRight . trimLeft . trimBottom . trimTop where
    trimRight = map $ reverse . (dropWhile (== "")) . reverse
    trimLeft csv = let margin = minimum
                                $ map length
                                $ map (takeWhile (== "")) csv in
                   map (drop margin) csv
    trimTop = dropWhile (all (== ""))
    trimBottom = reverse . trimTop . reverse

-- Non-structural fixups on the CSV.
tidy :: CSV -> CSV
tidy = upper . trimCells where
    upper = map $ map $ map toUpper
    trimCells = map $ map $ (reverse . (dropWhile isSpace) . reverse)

-- Read the CSV, parse everything.
readBunkPlan :: FilePath -> IO ([BunkAssignment], [BunkDefinition], [String])
readBunkPlan f = do
    csv <- parseCSVFromFile f
    case csv of
      Left err -> error $ concatMap messageString $ errorMessages err
      Right records -> do
                   let records' = filter (not . null) $ trimCSV records
                       (assignments, bunks, excludes) = split $ tidy records'
                       watchbill = parseAssignments assignments
                       bunkDefs = parseDefinitions bunks
                       excludes' = concat excludes
                   return (watchbill, bunkDefs, excludes')

-- Turn the input filename into an output filename.
makeFileName :: FilePath -> String -> FilePath
makeFileName template name = (dropExtension template) ++ "-" ++ name ++ ".html"

-- Print one cabin plan
printCabin :: FilePath
           -> (Map.Map String BunkDefinition)
           -> String
           -> [BunkAssignment]
           -> IO ()
printCabin template bunks name cabin =
    if null cabin
    then return ()
    else do
      let doctype = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n"
          filename = makeFileName template name
          size = length cabin
          smallCabin = size <= 5
          fontSize = if smallCabin then "6" else "5"

          title = (printf "BUNK PLAN %s" name) :: String
          theHead = header << thetitle << title
          theH1 = (h1 << title) ! [align "center"]

          spacer = if smallCabin then iterate (br +++) br !! 3 else noHtml

          headingCell label = th
                              << center
                              << (font << underline << label) ! [color navy]
          headingRow = foldl1 (+++) $ map headingCell ["BUNK", "WATCH", "NAME"]
          cell label = td << center << label
          bunk assign = bunkName $ bunks Map.! (bunkNumber assign)
          row assign = tr << ((cell $ bunk assign)
                              +++ (cell $ watchLabelColor $ watch assign)
                              +++ (cell $ Main.name assign))
          theRows = map row $ sortBy (compare `on` bunkNumber) cabin
          theTable = (table << (headingRow +++ theRows)) ! [cellpadding 5,
                                                            cellspacing 40]
          content = center << ((font << bold << theTable)
                               ! [Text.Html.size fontSize])
          theBody = body << (theH1 +++ content)
      writeFile filename (doctype
                          ++ (prettyHtml $ thehtml << (theHead +++ theBody)))

-- Build the cabin structures and print plans.
makeCabins :: FilePath
           -> ([BunkAssignment], [BunkDefinition], [String])
           -> IO ()
makeCabins filename (watchbill, bunks, excludes) = do
  -- Build a map of the watchbill, by bunk.
  let watchbillByBunk =
          foldl (\map assign ->
                     Map.insert (bunkNumber assign) assign map)
                Map.empty watchbill

  -- And a map of the bunks by bunk number.
  let bunksByNumber =
          foldl (\map def ->
                     Map.insert (number def) def map) Map.empty bunks

  -- And a map of the cabins, by cabin name.
  let bunksByCabin =
          Map.map reverse $
             foldl (\map def ->
                        Map.insertWith (++) (cabin def) [def] map)
                   Map.empty bunks

  -- And now a map of the people in each cabin, except the excludes
  let cabins =
          Map.filterWithKey (\cabin _ -> cabin `notElem` excludes) $
          Map.map (mapMaybe
                   (\bunk -> Map.lookup (number bunk) watchbillByBunk))
          bunksByCabin

  -- Now print everything!
  sequence_ $ map (uncurry $ printCabin filename bunksByNumber) $
            Map.toList cabins

-- Parse and print everything.
makeBunkPlan :: FilePath -> IO ()
makeBunkPlan fileName = readBunkPlan fileName >>= makeCabins fileName

-- Let's go!
main :: IO ()
main = do
  args <- getArgs
  if length args /= 1
    then do
      putStrLn "Must have a single filename argument."
      exitFailure
    else makeBunkPlan $ head args
